home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / srfi / srfi-26.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  1.8 KB  |  50 lines
  1. ;;; srfi-26.scm --- specializing parameters without currying.
  2.  
  3. ;; Copyright (C) 2002, 2006 Free Software Foundation, Inc.
  4. ;;
  5. ;; This library is free software; you can redistribute it and/or
  6. ;; modify it under the terms of the GNU Lesser General Public
  7. ;; License as published by the Free Software Foundation; either
  8. ;; version 2.1 of the License, or (at your option) any later version.
  9. ;; 
  10. ;; This library is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13. ;; Lesser General Public License for more details.
  14. ;; 
  15. ;; You should have received a copy of the GNU Lesser General Public
  16. ;; License along with this library; if not, write to the Free Software
  17. ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18.  
  19. (define-module (srfi srfi-26)
  20.   :export (cut cute))
  21.  
  22. (cond-expand-provide (current-module) '(srfi-26))
  23.  
  24. (define-macro (cut slot . slots)
  25.   (let loop ((slots    (cons slot slots))
  26.          (params    '())
  27.          (args    '()))
  28.     (if (null? slots)
  29.     `(lambda ,(reverse! params) ,(reverse! args))
  30.       (let ((s      (car slots))
  31.         (rest (cdr slots)))
  32.     (case s
  33.       ((<>)
  34.        (let ((var (gensym)))
  35.          (loop rest (cons var params) (cons var args))))
  36.       ((<...>)
  37.        (if (pair? rest)
  38.            (error "<...> not on the end of cut expression"))
  39.        (let ((var (gensym)))
  40.          `(lambda ,(append! (reverse! params) var)
  41.         (apply ,@(reverse! (cons var args))))))
  42.       (else
  43.        (loop rest params (cons s args))))))))
  44.  
  45. (define-macro (cute . slots)
  46.   (let ((temp (map (lambda (s) (and (not (memq s '(<> <...>))) (gensym)))
  47.            slots)))
  48.     `(let ,(delq! #f (map (lambda (t s) (and t (list t s))) temp slots))
  49.        (cut ,@(map (lambda (t s) (or t s)) temp slots)))))
  50.